home *** CD-ROM | disk | FTP | other *** search
/ Delphi Programmer's Power Pack / Delphi Volume 1.iso / e_to_l / fbuilder / delphi / demos / hlpxampl.pas < prev    next >
Pascal/Delphi Source File  |  1996-09-15  |  9KB  |  298 lines
  1. {*                                 *}
  2. {*  FormulaBuilder 1.0             *}
  3. {*  YGB Software, Inc.             *}
  4. {*  Copyright 1995 Clayton Collie  *}
  5. {*                                 *}
  6.  
  7.  {*                                                                     *}
  8.  {* This unit implements the functions discussed in the online help     *}
  9.  {* To use these functions, simply include this unit in the USES        *}
  10.  {* statement of any unit in your project (they register and unregister *}
  11.  {* automatically                                                       *}
  12.  {*                                                                     *}
  13.  
  14. Unit HlpXampl;
  15. INTERFACE
  16. uses FBCALC;
  17.  
  18.  
  19. IMPLEMENTATION
  20. Uses SYSUTILS,FBMISC,FBCOMP;
  21. var
  22.  CompInterestFnId,
  23.  RomanFnId,
  24.  SumSqFnId,
  25.  ParamInfoFnId,
  26.  AtSumFnId,
  27.  WhoCalledFNId : Integer;
  28.  
  29.  
  30. {*
  31.  *  Example 2
  32.  *
  33.  *  Consider the Compound Interest Formula
  34.  *
  35.  *  A =  P * (1 + i)^n
  36.  *
  37.  *  where A is the accumulated value, P is the principal,
  38.  *  I is the rate of interest and n is the number of periods
  39.  *  Here is how the function could be implemented :
  40.  *
  41.  *}
  42.  
  43. Procedure CompoundInterestProc(paramcount     : byte;
  44.                                const params   : TActParamList;
  45.                                var   Retvalue : TValueRec ;
  46.                                var   errcode  : integer;
  47.                                      ExprData : longint); export;
  48. var p, I , n : double;
  49.       A    : extended;
  50. begin
  51.     p := params[0].vFloat;
  52.     I := params[1].vFloat;
  53.     N := params[2].vFloat;
  54.     A := P * power(1 + i,n); { power is defined in FBMISC}
  55.     retvalue.vFloat  := A;
  56. end;
  57.  
  58.  
  59.  
  60. {*
  61.  * Callback Error Reporting Example
  62.  *
  63.  * Suppose we want to limit the range of values the user can enter
  64.  * as arguments to the ROMAN function from Example 1. The ROMAN function,
  65.  * takes an integer value and returns a Roman Numeral string.
  66.  *
  67.  * The Roman Function does not accept negative numbers. Also remember from
  68.  * our discussion that FormulaBuilder does automatic type conversions
  69.  * between compatible types to ensure that the correct parameter type is
  70.  * passed to a function. This would allow the user of the ROMAN function
  71.  * to type 'ROMAN(15.43)', which would be evaluated as ''ROMAN(15)'. We
  72.  * will disallow the of floating point numbers in our function .
  73.  *
  74.  * If a negative or floating point value were passed into the function
  75.  *  (for example Expression1.formula = 'Roman(-1)' ) then evaluation of
  76.  * the expression would terminate with the Status Property of the
  77.  * TExpression being set to EXPR_DOMAIN_ERROR.
  78.  *}
  79.  
  80. { RomanFunc with range checking }
  81. Procedure RomanProc( paramcount     : byte;
  82.                      const params   : TActParamList;
  83.                      var   retvalue : TValueRec;
  84.                      var   errcode  : integer;
  85.                            Exprdata : longint); export;
  86. var number : longint;
  87.     roman  : string[40];
  88. begin
  89.   { complain if there is a fractional part }
  90.   if (Frac(params[0].vFloat) - 1E6) > 0 then
  91.      Errcode := EXPR_TYPE_MISMATCH
  92.  else
  93.   if number < 0 then
  94.      errcode := EXPR_DOMAIN_ERROR { param is out of domain of function }
  95.  else                              { definition   }
  96.   begin
  97.     number := Trunc(params[0].vFloat);
  98.     roman  := Romanize(number)+#0;
  99.     retvalue.vpString := FBCreateString(@Roman[1]);
  100.   end;
  101. end;
  102.  
  103.  
  104.  
  105. {*
  106.  * Variable Parameter List Example 2
  107.  *
  108.  * The SUMSQ function returns the sum of the squares of its
  109.  * arguments. We can have as few as 1 and as many as 16 parameters
  110.  * of type float.
  111.  *
  112.  *}
  113.  
  114. Procedure SumSqProc(     paramcount  : byte;
  115.                       const params   : TActParamList;
  116.                       var   retvalue : TValueRec;
  117.                       var   errcode  : integer;
  118.                             Exprdata : longint); export;
  119. var i   : integer;
  120.     sum    : extended;
  121.     number : extended;
  122.     sqr    : Extended;
  123.  
  124. begin
  125.   sum := 0;
  126.   for i := 0 to pred(paramcount) do
  127.   begin
  128.     number := params[i].vFloat;
  129.     sum    := sum + (number * number);
  130.   end;
  131.   retvalue.vFloat := sum;
  132. end;
  133.  
  134.  
  135. {*
  136.  * The vtANY Type : Example 2
  137.  *
  138.  * It is not immediately obvious from the IIFProc example that the
  139.  * arguments can be of different types. To demonstrate this, we will
  140.  * implement a function PARMINFO which returns a string describing the
  141.  * parameters passed to it
  142.  *
  143.  *}
  144.  
  145.  Procedure ParamInfoProc( paramcount     : byte;
  146.                           const params   :  TActParamList;
  147.                           var   retvalue : TValueRec;
  148.                           var   errcode  : integer;
  149.                                 exprdata : longint); export;
  150.  var i      : integer;
  151.      tmpstr : string[255];
  152.      anycount,intcount,stringcount,
  153.      floatcount, boolcount, datecount : integer;
  154.  
  155.  begin
  156.    intcount    := 0;
  157.    floatcount  := 0;
  158.    boolcount   := 0;
  159.    datecount   := 0;
  160.    anycount    := 0;
  161.    stringcount := 0;
  162.    if paramcount = 0 then
  163.    begin
  164.      tmpstr  := ' No parameters '+#0;
  165.      retvalue.vpString := FBCreateString(@Tmpstr[1]);
  166.      exit;
  167.    end;
  168.    for i := 0 to pred(paramcount) do
  169.    with params[i] do
  170.    begin
  171.      case vtype of
  172.         vtInteger : inc(intCount);
  173.         vtstring  : inc(stringcount);
  174.         vtFloat   : inc(floatcount);
  175.         vtboolean : inc(boolCount);
  176.         vtdate    : inc(datecount);
  177.         vtany     : inc(AnyCount); { should NEVER get here }
  178.      end;
  179.    end;
  180.    tmpstr := ' %d Params : %d Ints, %d Strings,%d Booleans, %d Floats, '
  181.             +'%d Dates , %d variants ';
  182.  
  183.    tmpstr := format(tmpstr,[paramcount,intcount,stringcount,
  184.                             boolcount,floatcount,datecount,AnyCount]) + #0;
  185.  
  186.    retvalue.vpString := FBCreateString(@tmpstr[1]);
  187.  end;
  188.  
  189.  
  190. {*
  191.  * The vtANY Type : Example 3
  192.  *
  193.  * The built in SUM function takes only numeric values, and will
  194.  * raise an error if other types are entered as parameters. It is
  195.  * sometimes useful, however, to permit other types of arguments,
  196.  * whether or not the function uses them. Spreadsheets for example have
  197.  * functions such as @SUM and @AVG which work on ranges which may
  198.  * contain non-numeric data. In such cases those cells with non-numeric
  199.  * data are ignored.
  200.  *
  201.  * We will implement a sum function which works along the lines of a
  202.  * spreadsheet summation function, in other words, we will simply ignore
  203.  * non-numeric values rather than raise an error.
  204.  *
  205.  *}
  206.  Procedure AtSumProc( paramcount     : byte;
  207.                       const params   :  TActParamList;
  208.                       var   retvalue : TValueRec;
  209.                       var   errcode  : integer;
  210.                             exprdata : longint); export;
  211.  var i   : integer;
  212.      sum : extended;
  213.  
  214.  begin
  215.    sum := 0;  
  216.    for i := 0 to pred(paramcount) do
  217.    with params[i] do
  218.    begin
  219.      case vtype of
  220.         vtInteger : sum := sum + vInteger;
  221.         vtFloat   : sum := sum + vFloat;
  222.      end;
  223.    end;
  224.    retvalue.vFloat := sum;
  225.  end;
  226.  
  227.  
  228. {*
  229.  * ExprData Data Passing Example
  230.  *
  231.  * Observe the following code which implements the function WHOCALLED.
  232.  * The implicit typecast works only if WHOCALLED is called from a TExpression
  233.  * or descendant class:
  234.  *
  235.  * This can be especially useful for subclasses of TExpression which
  236.  * add additional methods and properties. Using this method, we have access
  237.  * to the public and published methods and properties of the TExpression
  238.  * instance.
  239.  *}
  240.  
  241.  Procedure ReturnCallerProc( paramcount     : byte;
  242.                              const params   :  TActParamList;
  243.                              var   retvalue : TValueRec;
  244.                              var   errcode  : integer;
  245.                                    exprdata : longint); export;
  246.  var i      : integer;
  247.      expr   : TExpression absolute exprdata;   {implicit typecast}
  248.      tmpstr : string;
  249.  
  250.  begin
  251.    try  {verify we are indeed being called from a TExpression }
  252.     tmpstr := 'Called from a '+Expr.ClassName+'. Formula  = '+
  253.               Expr.Formula + #0;
  254.    Except
  255.      on EGPFault do tmpstr := 'NOT